home *** CD-ROM | disk | FTP | other *** search
/ Acorn RISC PD-CD 1 / Acorn RISC PD-CD 1.iso / languages / _tile / f83 / minimal < prev    next >
Encoding:
Text File  |  1991-08-09  |  9.7 KB  |  390 lines
  1. \
  2. \  A MINIMAL FORTH MACHINE SIMULATOR AND META-COMPILER
  3. \
  4. \  Copyright (C) 1989-1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 1 August 1989
  15. \
  16. \  Last updated on: 23 August 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth
  20. \
  21. \  Description:
  22. \       This library illustrates how a virtual forth machine and most of
  23. \       the language can be realized with only nine primitive instructions.
  24. \       A simulator for the minimal forth virtual machine is defined
  25. \       together with a meta-compiler and implementations of a large
  26. \       section of the forth language.
  27. \
  28. \  Copying:
  29. \       This program is free software; you can redistribute it and\or modify
  30. \       it under the terms of the GNU General Public License as published by
  31. \       the Free Software Foundation; either version 1, or (at your option)
  32. \       any later version.
  33. \
  34. \       This program is distributed in the hope that it will be useful,
  35. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  36. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  37. \       GNU General Public License for more details.
  38. \
  39. \       You should have received a copy of the GNU General Public License
  40. \       along with this program; see the file COPYING.  If not, write to
  41. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  42.  
  43. .( Loading Minimal Forth Machine definitions...) cr
  44.  
  45. vocabulary minimal ( -- ) 
  46.  
  47. minimal definitions
  48.  
  49. forth
  50.  
  51. \ Hardware Devices: Registers and Stacks
  52.  
  53. : register ( -- ) create 0 , does> @ ;
  54. : -> ( x -- ) ' >body [compile] literal compile ! ; immediate compilation
  55. : stack ( n -- ) create here swap 2+ cells allot here over cell+ ! here swap ! 
  56. ;
  57. : push ( x s -- ) cell negate over +! @ ! ;
  58. : pop ( s -- x) dup @ @ cell rot +! ;
  59. : empty ( s -- ) dup cell+ @ swap ! ;
  60. : ?empty ( s -- bool) 2@ = ;
  61. : .stack ( s -- ) dup cell + @ swap @ ?do i @ . cell +loop ;
  62.  
  63.  
  64. \ Forth Machine Registers
  65.  
  66. register tos ( -- x | Top of stack register)
  67. register ir ( -- x | Instruction register)
  68. register ip ( -- x | Instruction pointer)
  69. 64 stack rp ( -- s | Return address stack)
  70. 64 stack sp ( -- s | Parameter stack)
  71.  
  72. \ Dump machine state
  73.  
  74. : .registers ( -- )
  75.   ." ir: " ir .name space              ( Dump name of current instruction)
  76.   ." ip: " ip cell - .                 ( Dump instruction pointer)
  77.   ." rp: " rp .stack                   ( Dump return stack)
  78.   ." tos: " tos .                      ( Dump top of stack register)
  79.   ." sp: " sp .stack cr                ( Dump parameter stack)
  80. ;
  81.  
  82.  
  83. \ Forth Machine Instructions
  84.  
  85. : instruction ( n -- ) create ; 
  86. : decode ( -- ) minimal [compile] ['] forth ; immediate compilation
  87.  
  88. instruction 1+
  89. instruction 0=
  90. instruction NAND
  91. instruction >R
  92. instruction R>
  93. instruction !
  94. instruction @
  95. instruction EXIT
  96. instruction DUMP
  97.  
  98. : CALL ( -- ) ip rp push ir >body -> ip ;
  99.  
  100.  
  101. \ The Minimal Forth Machine and additional state variables
  102.  
  103. variable trace ( -- addr | Trace function pointer)
  104. variable cycles ( -- addr | Instruction cycle counter)
  105. variable restart ( -- addr | Restart instruction pointer)
  106.  
  107. : reset-processor ( -- )
  108.   0 cycles !                           ( Initiate cycle counter)
  109.   restart -> ip                                ( And instruction pointer)
  110.   0 -> tos                             ( Clear top of stack)
  111.   sp empty                             ( And empty parameter stack)
  112.   rp empty                             ( And return stack)
  113. ;
  114.  
  115. : fetch-instruction ( -- instruction)
  116.   1 cycles +!                          ( Increment cycle counter)
  117.   ip @ dup -> ir                       ( Fetch next instruction)
  118.   ip cell+ -> ip                       ( And increment instruction pointer)
  119. ;
  120.  
  121. : processor ( -- )
  122.   reset-processor
  123.   begin
  124.     fetch-instruction
  125.     trace @ ?dup if execute then
  126.     case
  127.       decode 1+   of tos 1+ -> tos               endof
  128.       decode 0=   of tos 0= -> tos               endof
  129.       decode NAND of sp pop tos and not -> tos   endof
  130.       decode >R   of tos rp push sp pop -> tos   endof
  131.       decode R>   of tos sp push rp pop -> tos   endof
  132.       decode !    of sp pop tos ! sp pop -> tos  endof
  133.       decode @    of tos @ -> tos                endof
  134.       decode EXIT of rp pop -> ip                endof
  135.       decode DUMP of .registers                  endof
  136.       CALL
  137.     endcase
  138.     rp ?empty
  139.   until
  140. ;
  141.  
  142. : run ( -- ) ' restart ! processor ." cycles: " cycles @ . .registers ;
  143. : trace-instructions ( -- ) ['] .registers trace ! ;
  144.  
  145.  
  146. \ A simple meta-compiler for the Minimal Forth Machine
  147.  
  148. minimal
  149.  
  150. : CREATE ( -- ) create ; 
  151. : COMPILE ( -- ) compile compile ; immediate
  152.  
  153. : DEFINE ( -- ) CREATE ] ;
  154. : END ( -- ) COMPILE EXIT [compile] [ ; immediate
  155. : BLOCK ( n -- ) cells allot ;
  156. : DATA ( -- ) , ;
  157.  
  158.  
  159. \ Variable management
  160.  
  161. DEFINE [VARIABLE] ( -- addr) R> END
  162. : VARIABLE ( -- addr) CREATE COMPILE [VARIABLE] 1 BLOCK ; 
  163.  
  164.  
  165. \ Constant management
  166.  
  167. DEFINE [CONSTANT] ( -- n) R> @ END
  168. : CONSTANT ( n -- ) CREATE COMPILE [CONSTANT] DATA ;
  169.  
  170.  
  171. \ Basic stack manipulation functions
  172.  
  173. VARIABLE TEMP ( -- addr)
  174.  
  175. DEFINE DROP ( x -- ) TEMP ! END
  176. DEFINE DUP ( x -- x x) TEMP ! TEMP @ TEMP @ END
  177. DEFINE SWAP ( x y -- y x) TEMP ! >R TEMP @ R> END
  178. DEFINE ROT ( x y z -- y z x) >R SWAP R> SWAP END
  179. DEFINE OVER ( x y -- x y x) >R DUP R> SWAP END
  180. DEFINE R@ ( -- x) R> R> DUP >R SWAP >R END
  181.  
  182.  
  183. \ Basic logical functions
  184.  
  185. -1 CONSTANT TRUE ( -- true)
  186.  0 CONSTANT FALSE ( -- false)
  187.  
  188. DEFINE BOOLEAN ( x -- bool) 0= 0= END
  189. DEFINE NOT ( x y -- z) DUP NAND END
  190. DEFINE AND ( x y -- z) NAND NOT END
  191. DEFINE OR ( x y -- z) NOT SWAP NOT NAND END
  192. DEFINE XOR ( x y -- y) OVER OVER NOT NAND >R SWAP NOT NAND R> NAND END
  193.  
  194.  
  195. \ Primitive arithmetic constants and functions
  196.  
  197. -2147483648 CONSTANT MIN-INT ( -- int)
  198. -2 CONSTANT -2 ( -- int)
  199. -1 CONSTANT -1 ( -- int)
  200.  0 CONSTANT 0 ( -- int)
  201.  1 CONSTANT 1 ( -- int)
  202.  2 CONSTANT 2 ( -- int)
  203.  2147483647 CONSTANT MAX-INT ( -- int)
  204.  
  205. DEFINE 1- ( x -- y) NOT 1+ NOT END
  206. DEFINE 2+ ( x -- y) 1+ 1+ END
  207. DEFINE 2- ( x -- y) NOT 2+ NOT END
  208.  
  209.  
  210. \ Additional relational functions
  211.  
  212. DEFINE 0< ( x -- bool) MIN-INT AND BOOLEAN END
  213. DEFINE 0> ( x -- bool) DUP 0= SWAP 0< OR NOT BOOLEAN END
  214.  
  215.  
  216. \ Cell sizes and cell increment function
  217.  
  218. 4 CONSTANT CELL ( -- num)
  219. DEFINE CELL+ ( x -- y) 1+ 1+ 1+ 1+ END
  220.  
  221.  
  222. \ Branch functions
  223.  
  224. DEFINE (BRANCH) ( -- ) R> @ >R END
  225. DEFINE (?BRANCH) ( bool -- ) 0= DUP R@ @ AND SWAP NOT R> CELL+ AND OR >R END
  226.  
  227.  
  228. \ Compiler functions
  229.  
  230. : >MARK ( -- addr) here cell allot ;
  231. : >RESOLVE ( addr -- ) here swap (forth) ! ;
  232. : <MARK ( -- addr) here ;
  233. : <RESOLVE ( -- addr) , ;
  234.  
  235. : IF ( bool -- ) COMPILE (?BRANCH) >MARK ; immediate
  236. : ELSE ( -- ) COMPILE (BRANCH) >MARK swap >RESOLVE ; immediate
  237. : THEN ( -- ) >RESOLVE ; immediate
  238. : BEGIN ( -- ) <MARK ; immediate
  239. : WHILE ( bool -- ) COMPILE (?BRANCH) >MARK ; immediate
  240. : REPEAT ( -- ) COMPILE (BRANCH) swap <RESOLVE >RESOLVE ; immediate
  241. : UNTIL ( bool -- ) COMPILE (?BRANCH) <RESOLVE ; immediate
  242. : AGAIN ( -- ) COMPILE (BRANCH) <RESOLVE ; immediate
  243.  
  244.  
  245. \ Additional stack functions
  246.  
  247. DEFINE ?DUP ( n -- [n n] or [0]) DUP IF DUP THEN END
  248. DEFINE TUCK ( x y -- y x y) SWAP OVER END
  249. DEFINE NIP ( x y -- y) SWAP DROP END
  250. DEFINE 2DUP ( x y -- x y x y) OVER OVER END
  251. DEFINE 2DROP ( x y -- ) DROP DROP END
  252.  
  253.  
  254. \ Arithmetical functions
  255.  
  256.    
  257. DEFINE NEGATE ( x -- y) NOT 1+ END
  258. DEFINE ABS ( x -- y) DUP 0< IF NEGATE THEN END
  259.  
  260. DEFINE + ( x y -- z)
  261.   DUP 0<
  262.   IF BEGIN DUP WHILE 1+ SWAP 1- SWAP REPEAT 
  263.   ELSE BEGIN DUP WHILE 1- SWAP 1+ SWAP REPEAT THEN
  264.   DROP
  265. END
  266.  
  267. DEFINE - ( x y -- z) NEGATE + END
  268.  
  269. DEFINE U< ( x y -- bool)
  270.   BEGIN
  271.     DUP IF 1- ELSE 2DROP FALSE EXIT THEN
  272.     SWAP
  273.     DUP IF 1- ELSE 2DROP TRUE EXIT THEN
  274.     SWAP
  275.   AGAIN
  276. END
  277.   
  278. DEFINE U* ( x y -- z)
  279.   >R 0 SWAP
  280.   BEGIN DUP WHILE 1- SWAP R@ + SWAP REPEAT
  281.   R> 2DROP
  282. END
  283.  
  284. DEFINE U/MOD ( x y -- q r) 
  285.   >R 0 SWAP 
  286.   BEGIN DUP R@ - DUP 0< NOT WHILE SWAP DROP SWAP 1+ SWAP REPEAT
  287.   R> 2DROP
  288. END
  289.  
  290. DEFINE * ( x y -- z) 
  291.   2DUP XOR 0< >R
  292.   ABS SWAP ABS SWAP U*
  293.   R> IF NEGATE THEN
  294. END
  295.  
  296. DEFINE /MOD ( x y -- q r) 
  297.   2DUP XOR 0< >R OVER 0< >R 
  298.   ABS SWAP ABS SWAP U/MOD 
  299.   R> IF NEGATE THEN 
  300.   R> IF SWAP NEGATE SWAP THEN
  301. END
  302.  
  303. DEFINE / ( x y -- q) /MOD DROP END
  304. DEFINE MOD ( x y -- r) /MOD NIP END
  305.  
  306. DEFINE = ( x y -- bool) XOR BOOLEAN NOT END
  307. DEFINE < ( x y -- bool) - 0< END
  308. DEFINE > ( x y -- bool) - 0> END
  309.  
  310. DEFINE MIN ( x y -- z) 2DUP > IF SWAP THEN DROP END
  311. DEFINE MAX ( x y -- z) 2DUP < IF SWAP THEN DROP END
  312.  
  313.  
  314. \ Number literals in meta-code
  315.  
  316. DEFINE (LITERAL) ( -- ) R> DUP @ SWAP CELL+ >R END
  317. : LITERAL ( x -- ) COMPILE (LITERAL) , ; immediate
  318.  
  319.  
  320. \ And some test code just to show that it actually works
  321.  
  322. DEFINE LOGIC-TEST ( -- )
  323.   [ 5 ] LITERAL NOT
  324.   [ 5 ] LITERAL [ 3 ] LITERAL AND
  325.   [ 5 ] LITERAL [ 3 ] LITERAL OR
  326.   [ 5 ] LITERAL [ 3 ] LITERAL XOR
  327.  
  328.   [ 5 ] LITERAL 0=
  329.   [ 5 ] LITERAL 0<
  330.   [ 5 ] LITERAL 0>
  331.  
  332.   [ 5 ] LITERAL [ 3 ] LITERAL =
  333.   [ 5 ] LITERAL [ 3 ] LITERAL <
  334.   [ 5 ] LITERAL [ 3 ] LITERAL >
  335.  
  336.   [ 5 ] LITERAL [ 5 ] LITERAL =
  337.   [ 3 ] LITERAL [ 5 ] LITERAL <
  338.   [ 3 ] LITERAL [ 5 ] LITERAL >
  339. END
  340.  
  341. run LOGIC-TEST
  342.  
  343. DEFINE ARITHMETIC-TEST ( -- )
  344.   [ 5 ] LITERAL NEGATE
  345.  
  346.   [ 5 ] LITERAL ABS
  347.   [ -5 ] LITERAL ABS
  348.  
  349.   [ 5 ] LITERAL [ 3 ] LITERAL MAX
  350.   [ 5 ] LITERAL [ 3 ] LITERAL MIN
  351.   
  352.   [ 5 ] LITERAL [ 3 ] LITERAL +
  353.   [ 5 ] LITERAL [ 3 ] LITERAL -
  354.  
  355.   [ 5 ] LITERAL [ 3 ] LITERAL *
  356.   [ 5 ] LITERAL [ -3 ] LITERAL *
  357.   [ -5 ] LITERAL [ 3 ] LITERAL *
  358.   [ -5 ] LITERAL [ -3 ] LITERAL *
  359.  
  360.   [ 5 ] LITERAL [ 3 ] LITERAL /MOD
  361.   [ 5 ] LITERAL [ -3 ] LITERAL /MOD
  362.   [ -5 ] LITERAL [ 3 ] LITERAL /MOD
  363.   [ -5 ] LITERAL [ -3 ] LITERAL /MOD
  364. END
  365.  
  366. run ARITHMETIC-TEST 
  367.  
  368. DEFINE FIB ( n -- m)
  369.    DUP 1- 0= OVER 0= OR NOT
  370.    IF DUP 1- FIB SWAP 2- FIB + THEN
  371. END
  372.  
  373. DEFINE FIB-TEST ( -- )
  374.   [ 8 ] LITERAL FIB
  375. END
  376.  
  377. run FIB-TEST
  378.  
  379. DEFINE FAC ( n -- n!)
  380.   DUP IF DUP 1- FAC * ELSE DROP 1 THEN
  381. END  
  382.  
  383. DEFINE FAC-TEST ( -- )
  384.   [ 5 ] LITERAL FAC
  385. END
  386.   
  387. run FAC-TEST
  388.  
  389. forth only
  390.